unit compiler;

interface

uses classes,sysutils,vm,unicode;

procedure compilerwords    (vm:TKsanaForthVM);
procedure forth_abort      (vm:TKsanaForthVM);
procedure forth_here       (vm:TKsanaForthVM);
procedure forth_wordparse  (vm:TKsanaForthVM);
procedure forth_zword      (vm:TKsanaForthVM);
procedure forth_word       (vm:TKsanaForthVM);
procedure forth_words      (vm:TKsanaForthVM);
procedure forth_bl         (vm:TKsanaForthVM);
procedure forth_head       (vm:TKsanaForthVM);
procedure forth_colon      (vm:TKsanaForthVM);
procedure forth_dovar      (vm:TKsanaForthVM);
procedure forth_variable   (vm:TKsanaForthVM);
procedure forth_2variable  (vm:TKsanaForthVM);
procedure forth_create     (vm:TKsanaForthVM);
procedure forth_docon      (vm:TKsanaForthVM);
procedure forth_constant   (vm:TKsanaForthVM);
procedure forth_do2con     (vm:TKsanaForthVM);
procedure forth_2constant  (vm:TKsanaForthVM);
procedure forth_dodoes     (vm:TKsanaForthVM);
procedure forth_does       (vm:TKsanaForthVM);
procedure forth_doret      (vm:TKsanaForthVM);
procedure forth_semicolon  (vm:TKsanaForthVM);
procedure forth_comma      (vm:TKsanaForthVM);
procedure forth_cells_allot(vm:TKsanaForthVM);
procedure forth_immediate  (vm:TKsanaForthVM);
procedure forth_isimmediate(vm:TKsanaForthVM);
procedure forth_compileonly(vm:TKsanaForthVM);
procedure forth_iscompileonly(vm:TKsanaForthVM);
procedure forth_nop        (vm:TKsanaForthVM);
procedure forth_dolit      (vm:TKsanaForthVM);
procedure forth_dostrq     (vm:TKsanaForthVM);
procedure forth_dodotq     (vm:TKsanaForthVM);
procedure forth_dotq       (vm:TKsanaForthVM);
procedure forth_dowstrq    (vm:TKsanaForthVM);
procedure forth_strcomma (vm:TKsanaForthVM);

implementation

uses io,structure;

procedure forth_here(vm:TKsanaForthVM);
begin vm.push(vm.cp);
end;

procedure forth_eval(vm:TKsanaForthVM);
var
  s:string;
begin
  vm.pop;
  s:=pchar(vm.pop);
  vm.eval(s);
end;

procedure forth_zword(vm:TKsanaForthVM);
var delimiter:char;
begin delimiter:=char(vm.tos);
  vm.tos:=integer(pchar(vm.zword(delimiter))); //return the zero-ended string
end;
procedure forth_wordparse(vm:TKsanaForthVM);
begin forth_zword(vm); vm.push(length(pchar(vm.tos)));
end;

procedure forth_word(vm:TKsanaForthVM);
var n:integer; s:string;
begin s:=pchar(vm.token);
   forth_zword(vm); n:=length(s);
   s:=char(n)+s;
   vm.tos:=integer(pchar(s));
end;

procedure debug;
begin
end;

procedure forth_words(vm:TKsanaForthVM);
var a,i,j:integer; s1,s2,n,m,t:string;
begin
  t:=''; s1:=vm.zword; if s1<>'' then s2:=vm.zword;
  for i:=vm.words.count-1 downto 0 do begin
      n:=vm.words[i];
      j:=0;
      if s1<>'' then begin
         j:=pos(s1,n); m:=copy(n,j+1,length(n)-j);
      end;
      if (s1='')or
         ((j>0)and(s2=''))or
         ((j>0)and(s2<>'')and(pos(s2,m)>0)) then begin
         a:=tForthWord(vm.words.Objects[i]).address;
         t:=t+format(' %x %s',[a,n]);
         if length(t)>50 then begin
            vm.push(integer(pchar(t))); forth_ztype(vm);
            vm.cr; t:='';
         end;
      end;
  end;
  if length(t)>0 then begin
     vm.push(integer(pchar(t))); forth_ztype(vm);
  end;
end;

procedure forth_bl(vm:TKsanaForthVM);
begin vm.push($20);
end;

procedure forth_head(vm:TKsanaForthVM);
var s:string;
begin s:=vm.zword;
  vm.makehead(pchar(s),length(s));
end;

procedure forth_colon(vm:TKsanaForthVM);
begin
 forth_head(vm); vm.compiling:=true;
end;

procedure forth_dovar(vm:TKsanaForthVM);
begin
  vm.push(vm.ip);
  forth_doret(vm);
end;

procedure forth_variable(vm:TKsanaForthVM);
begin
  forth_create(vm); // & address of code following does>
  vm.compilecell(0);
end;

procedure forth_2variable(vm:TKsanaForthVM);
begin
  forth_create(vm); // & address of code following does>
  vm.compilecell(0);
  vm.compilecell(0);
end;

procedure forth_create(vm:TKsanaForthVM);
begin
  forth_head(vm); vm.compiling:=false; vm.overt;
  vm.compilecode(integer(@forth_nop));   //will be replaced by dodoes
  vm.compilecode(integer(@forth_dovar));//or COMPILEONLY_MASK); // & address of code following does>
end;

procedure forth_docon(vm:TKsanaForthVM);
begin
  vm.push(integer(pointer(vm.ip)^));
  forth_doret(vm);
end;

procedure forth_do2con(vm:TKsanaForthVM);
begin
  vm.dpush(pint64(vm.ip)^);
  forth_doret(vm);
end;

procedure forth_constant(vm:TKsanaForthVM);
begin
  forth_head(vm); vm.compiling:=false; vm.overt;
  vm.compilecode(integer(@forth_docon));//or COMPILEONLY_MASK); // & address of code following does>
  vm.compilecell(integer(vm.pop));   //will be replaced by dodoes
end;

procedure forth_2constant(vm:TKsanaForthVM);
var i:integer;
begin
  forth_head(vm); vm.compiling:=false; vm.overt;
  vm.compilecode(integer(@forth_do2con));  /// forth_docon
  i:=vm.pop;
  vm.compilecell(integer(vm.pop));
  vm.compilecell(i);
end;

procedure forth_dodoes(vm:TKsanaForthVM);
begin
  vm.push(vm.ip+CELLSIZE); // push data address
  forth_branch(vm); // jump to address of code following does>
end;

procedure forth_does(vm:TKsanaForthVM);
begin
//  pinteger(vm.toreal(vm.lastwordcfa))^:=integer(@forth_dodoes) or CODEWORD_MASK or COMPILEONLY_MASK;  // previously nop
//  pinteger(vm.toreal(vm.lastwordcfa+CELLSIZE))^:=vm.ip;

  pinteger(vm.lastwordcfa)^:=integer(@forth_dodoes);// or CODEWORD_MASK or COMPILEONLY_MASK;  // previously nop
  pinteger(vm.lastwordcfa+CELLSIZE)^:=vm.ip;

  forth_doret(vm);
end;

// phase 1 ---- : TEST CREATE , DOES>  @ DUP * . ; ( define defining word TEST )
// phase 2 ---- 7 TEST X                           ( use defining word TEST to define X )
// phase 3 ---- X        // output 49              ( use X )


procedure forth_doret(vm:TKsanaForthVM);
begin
  if vm.rp=-1 then begin
    vm.exitloop:=true;
  end else begin
    vm.ip:=vm.rpop;
  end;
end;

procedure forth_exit(vm:TKsanaForthVM);
begin
  if vm.rp=-1 then begin
    vm.exitloop:=true;
  end else begin
    vm.ip:=vm.rpop;
  end;
end;

procedure forth_qexit(vm:TKsanaForthVM);
begin if vm.pop<>0 then
  forth_exit(vm);
end;

procedure forth_semicolon(vm:TKsanaForthVM);
begin
  vm.compiling:=false;
  vm.compilecode(integer(@forth_doret));//or COMPILEONLY_MASK);
  vm.overt;
end;

procedure forth_comma(vm:TKsanaForthVM);
begin
  vm.compilecell(vm.pop);
end;

procedure forth_cells_allot(vm:TKsanaForthVM);
var
  i,cells:integer;
begin
  cells:=vm.pop;
  for i:=1 to cells do begin
    vm.compilecell(0);
  end;
end;

procedure forth_allot(vm:TKsanaForthVM);
var
  i,cells:integer;
begin
  cells:=align(vm.pop+3) div 4;
  for i:=1 to cells do begin
    vm.compilecell(0);
  end;
end;

//make last word immediate
procedure forth_immediate(vm:TKsanaForthVM);
begin
  vm.setimmediate;
end;

procedure forth_isimmediate(vm:TKsanaForthVM);
var theword:TForthword; cfa:integer; isimmediate:boolean;
begin
  cfa:=vm.pop; theword:=vm.token2word(cfa);
  if theword=nil then isimmediate:=false
  else isimmediate:=theword.immediate;
  vm.push(integer(isimmediate));
end;

procedure forth_compileonly(vm:TKsanaForthVM);
begin
  vm.setcompileonly;
end;

procedure forth_iscompileonly(vm:TKsanaForthVM);
var theword:TForthword; cfa:integer; iscompileonly:boolean;
begin
  cfa:=vm.pop;
  theword:=vm.token2word(cfa);
  if theword=nil then iscompileonly:=false
  else iscompileonly:=theword.compileonly;
  vm.push(integer(iscompileonly));
end;

procedure forth_nop(vm:TKsanaForthVM);
begin
end;

procedure forth_dolit(vm:TKsanaForthVM);
var r:integer;
begin //fetch the value in current IP, and advance to next cell
  r:=pinteger(vm.ip)^;
  inc(vm.ip,CELLSIZE);
  vm.push(r);
end;

procedure forth_dochar(vm:TKsanaForthVM);
var c:integer;
begin //fetch the value in current IP, and advance to next cell
  c:=pinteger(vm.ip)^ and $FF;
  inc(vm.ip,CELLSIZE);
  vm.push(c);
end;

procedure forth_dotick(vm:TKsanaForthVM);
var n:integer;
begin //fetch the token in current IP, and advance to next cell
  n:=pinteger(vm.ip)^;
  inc(vm.ip,CELLSIZE);
  vm.push(n);
end;

procedure forth_btick(vm:TKsanaForthVM);
begin //get the following word as a literal
  vm.compilecell(integer(@forth_dotick));
end;

procedure forth_char(vm:TKsanaForthVM);
begin //get ascii code value of the following char
  vm.push(integer(pchar(vm.zword)^));
end;

procedure forth_bchar(vm:TKsanaForthVM);
begin //get ascii code value of the following char as a literal
  vm.compilecode(integer(@forth_dochar));//or COMPILEONLY_MASK);
  vm.compilecell(integer(pchar(vm.zword)^));
end;

//quote string runtime
procedure forth_dostrq(vm:TKsanaForthVM);
var
  count:integer;
  str:pchar;
begin
  count:=pinteger(vm.ip)^;
  inc(vm.ip,CELLSIZE);
  str:=pchar(pinteger(vm.ip));
  //skip ip to end of string
  inc(vm.ip, align(count+1)); //// sam 20100801

  vm.push(integer(str));
  vm.push(count);
end;
procedure forth_dodotq(vm:TKsanaForthVM);
var
  count:integer;
  str:pchar;
begin
  count:=pinteger(vm.ip)^;
  inc(vm.ip,CELLSIZE);
  str:=pchar(pinteger(vm.ip));
  //skip ip to end of string
  inc(vm.ip, align(count+1)); //// sam 20100801
  vm.push(integer(str));
  forth_ztype(vm);
end;
//quote wide string runtime
procedure forth_dowstrq(vm:TKsanaForthVM);
var
  count:integer;
  str:pwidechar;
begin
  count:=pinteger(vm.ip)^ * 2;
  inc(vm.ip,CELLSIZE);
  str:=pwidechar(pinteger(vm.ip));
  //skip ip to end of string
  inc(vm.ip, align(count+2)); //// sam 20100801

  vm.push(integer(str));
  vm.push(count div 2);
end;

procedure forth_abort(vm:TKsanaForthVM);
begin
  vm.aborting:=true;
end;

procedure forth_quit(vm:TKsanaForthVM);
begin
  vm.aborting:=true;
end;

procedure forth_tobody(vm:TKsanaForthVM);
begin
  vm.tos:=(vm.tos)+8;
end;

procedure forth_compiling(vm:TKsanaForthVM);
begin vm.push(integer(vm.compiling));
end;

procedure forth_compiling_on(vm:TKsanaForthVM);
begin vm.compiling:=true;
end;

procedure forth_compiling_off(vm:TKsanaForthVM);
begin vm.compiling:=false;
end;

procedure forth_compile(vm:TKsanaForthVM);
begin vm.compilecell(pinteger(vm.ip)^); inc(vm.ip,CELLSIZE);
end;

procedure forth_literal(vm:TKsanaForthVM);
begin vm.compilelit(integer(vm.pop));
end;

//compile a string
procedure forth_wstrcomma (vm:TKsanaForthVM);
var
  str:widestring;
  count:integer;
  utf8:pchar;
begin
  count:=vm.pop;
  utf8:=pchar(vm.pop);


  str:=utf8towidestring(copy(utf8,1,count));
  count:=length(str);

  vm.compilecode(integer(@forth_dowstrq));//or COMPILEONLY_MASK); //strq runtime
  vm.compilecell(count);                  //string byte count
  StrLCopyW( pwidechar(vm.cp), pwidechar(str) , count);     //body of string
  inc(vm.cp,count*2);
    pwidechar(vm.cp)^:=#0;
    inc(vm.cp);
   vm.cp:=align(vm.cp); //// sam 20100801
end;

//quote wide string compiler
procedure forth_wstrq(vm:TKsanaForthVM);

begin
  vm.push( $22 ); // "
  forth_wordparse(vm);
  forth_wstrcomma(vm);
end;
procedure strcomma (vm:TKsanaForthVM;str:pchar;count:integer);
begin
  vm.compilecell(count);                  //string byte count
  strLcopy( pchar(vm.cp), str , count);     //body of string
  inc(vm.cp,count);
  pchar(vm.cp)^:=#0; inc(vm.cp);
  vm.cp:=align(vm.cp); //// sam 20100801
end;
procedure forth_strcomma (vm:TKsanaForthVM);
var
  str:pchar;
  count:integer;
begin
  count:=vm.pop;
  str:=pchar(vm.pop);
  vm.compilecode(integer(@forth_dostrq));
  strcomma(vm,str,count);
end;
//quote string compiler
procedure forth_strq(vm:TKsanaForthVM);
var s:string;
begin 
  s:=vm.zword('"');
  vm.compilecode(integer(@forth_dostrq));
  strcomma(vm,pchar(s),length(s));
end;
procedure forth_dotq(vm:TKsanaForthVM);
var s:string;
begin
  s:=vm.zword('"');
  vm.compilecode(integer(@forth_dodotq));
  strcomma(vm,pchar(s),length(s));
end;

procedure forth_toinfetch(vm:TKsanaForthVM);
begin
  vm.push(integer(pchar(vm.ptib)));
end;

procedure forth_toinstore(vm:TKsanaForthVM);
begin
  vm.ptib:=pchar(vm.pop);
end;

procedure forth_tib(vm:TKsanaForthVM);
begin
  vm.push(integer(pchar(vm.tib)));
end;

procedure forth_vocbegin(vm:TKsanaForthVM);
begin
  vm.push(vm.vocbgn);
end;

procedure forth_voclimit(vm:TKsanaForthVM);
begin
  vm.push(vm.voclmt);
end;

procedure forth_numberwords(vm:TKsanaForthVM);
begin
  vm.push(vm.voc.count);
end;

procedure compilerwords(vm:TKsanaForthVM);
begin
  vm.addcodeword('exit',integer(@forth_exit),false,true); //// ( -- )
  vm.addcodeword('?exit',integer(@forth_qexit),false,true); //// ( f -- )
  vm.addcodeword('immediate',integer(@forth_immediate)); //// ( -- )
  vm.addcodeword('isimmediate',integer(@forth_isimmediate)); //// ( cfa -- f )
  vm.addcodeword('compileonly',integer(@forth_compileonly)); //// ( -- )
  vm.addcodeword('iscompileonly',integer(@forth_iscompileonly)); //// ( cfa -- f )
  vm.addcodeword(']',integer(@forth_compiling_on)); //// ( -- )
  vm.addcodeword('[',integer(@forth_compiling_off),true); //// ( -- )
  vm.addcodeword('compiling',integer(@forth_compiling)); //// ( -- f )
  vm.addcodeword('literal',integer(@forth_literal),true,true); //// ( n -- )
  vm.addcodeword('compile',integer(@forth_compile),false,true); //// ( -- )
  vm.addcodeword('>body',integer(@forth_tobody)); //// ( cfa -- bfa )
  vm.addcodeword('quit',integer(@forth_quit)); //// ( -- )
  vm.addcodeword('abort',integer(@forth_abort)); //// ( ... n2 n1 -- )
  vm.addcodeword('nop',integer(@forth_nop)); //// ( -- )
  vm.addcodeword('bl',integer(@forth_bl)); //// ( -- $20 )
  vm.addcodeword('zword',integer(@forth_zword)); //// ( c -- a ) zero-ended string
  vm.addcodeword('word',integer(@forth_word)); //// ( c -- a ) counted-string
  vm.addcodeword('wordparse',integer(@forth_wordparse)); //// ( c -- a n )
  vm.addcodeword('words',integer(@forth_words)); //// ( -- ) sorded words
  vm.addcodeword(':',integer(@forth_colon)); //// { -- )
  vm.addcodeword(';',integer(@forth_semicolon),true,true); //// ( -- )
  vm.addcodeword('(s")',integer(@forth_dostrq),false,true); //// ( -- )
  vm.addcodeword('(.")',integer(@forth_dodotq),false,true); //// ( -- )
  vm.addcodeword('s"',integer(@forth_strq),true,true); //// ( -- )
  vm.addcodeword('(ws")',integer(@forth_dowstrq),false,true); //// ( -- )
  vm.addcodeword('ws"',integer(@forth_wstrq),true,true); //// ( -- )
  vm.addcodeword('ws,',integer(@forth_wstrcomma),true,true); //// ( -- )
  vm.addcodeword('s,',integer(@forth_strcomma),true,true); //// ( a n -- )
  vm.addcodeword('."',integer(@forth_dotq),true,true); //// ( -- )
  vm.addcodeword('here',integer(@forth_here)); //// ( -- a )
  vm.addcodeword('create',integer(@forth_create)); //// ( <name> -- )
  vm.addcodeword('variable',integer(@forth_variable)); //// ( <name> -- )
  vm.addcodeword('2variable',integer(@forth_2variable)); //// ( <name> -- )
  vm.addcodeword('constant',integer(@forth_constant)); //// ( i <name> -- )
  vm.addcodeword('2constant',integer(@forth_2constant)); //// ( ilow ihigh <name> -- )
  vm.addcodeword('does>',integer(@forth_does)); //// ( -- )
  vm.addcodeword('eval',integer(@forth_eval)); //// ( a n -- )
  vm.addcodeword(',',integer(@forth_comma)); //// ( n -- )
  vm.addcodeword('cells_allot',integer(@forth_cells_allot)); //// ( n -- )
  vm.addcodeword('allot',integer(@forth_allot)); //// ( n -- )
  vm.addcodeword('['']',integer(@forth_btick),true,true); //// ( -- )
  vm.addcodeword('('')',integer(@forth_dotick),false,true); //// ( -- cfa )
  vm.addcodeword('(literal)',integer(@forth_dolit),false,true); //// ( -- n )
  vm.addcodeword('char',integer(@forth_char)); //// ( -- c )
  vm.addcodeword('[char]',integer(@forth_bchar),true,true); //// ( -- )
  vm.addcodeword('(char)',integer(@forth_dochar),false,true); //// ( -- c )
  vm.addcodeword('(variable)',integer(@forth_dovar),false,true); //// ( -- a )
  vm.addcodeword('(constant)',integer(@forth_docon),false,true); //// ( -- n )
  vm.addcodeword('(;)',integer(@forth_doret),false,true); //// ( -- )
  vm.addcodeword('(does>)',integer(@forth_dodoes),false,true); //// ( -- a )
  vm.addcodeword('tib',integer(@forth_tib)); //// ( -- a )
  vm.addcodeword('>in@',integer(@forth_toinfetch)); //// ( -- a )
  vm.addcodeword('>in!',integer(@forth_toinstore)); //// ( a -- )
  vm.addcodeword('vocbegin',integer(@forth_vocbegin)); //// ( -- a )
  vm.addcodeword('voclimit',integer(@forth_voclimit)); //// ( -- a )
  vm.addcodeword('#words',integer(@forth_numberwords)); //// ( -- a )

end;

end.
